( Portable, Stack Based String Library for fbForth V2.0   )
( Version 1.0 - Mark Wills September 2014.                )
( Ported from the original TurboForth code by Mark Wills  )

BASE @  DECIMAL

256 CONSTANT ($sSize)      ( store stack size)
HERE 
($sSize) ALLOT             ( reserve space for string stack)
CONSTANT ($sEnd)           ( bottom of string stack )
0 VARIABLE ($sp)           ( pointer to top of string stack)
($sEnd) ($sSize) + ($sp) ! ( initialise it)
0 VARIABLE ($depth)        ( count of items on the string stack)
0 VARIABLE ($temp0)        ( reserved for internal use)
0 VARIABLE ($temp1)        ( reserved for internal use)
0 VARIABLE ($temp2)        ( reserved for internal use)
0 VARIABLE ($temp3)        ( reserved for internal use)

( ************** WORDS REQUIRED BY fbForth ******************** )
: 2DUP ( A B -- A B A B ) OVER OVER ;    
: NIP ( A B -- B ) SWAP DROP ;
: CELLS ( N -- Nx2 ) 2 * ;
: -ROT ( A B C -- C A B ) ROT ROT ;
: PICK ( N -- [N]) 1+ CELLS SP@ + @ ;
: WITHIN ( n low high -- true|false ) OVER - >R - R> U< ;
: <> ( A B -- 1|0 ) = 0= ;
: EXIT ( -- ) [COMPILE] ;S ; IMMEDIATE
: $. 16 BASE ! U. 10 BASE ! ;
( ************************************************************* )

( Throw codes used by this library: )
: (throw) ( code -- )
    CASE 
        9900 OF ." String stack underflow" ENDOF
        9901 OF ." String too large to assign" ENDOF 
        9902 OF ." String stack is empty" ENDOF 
        9903 OF ." Need at least 2 strings on string stack" ENDOF
        9904 OF ." String too large for string constant" ENDOF 
        9905 OF ." Illegal LEN value" ENDOF 
        9906 OF ." Need at least 3 strings on string stack" ENDOF 
        9908 OF ." Illegal start value" ENDOF
    ENDCASE
    CR ABORT ;

: ($depth+) ( -- )
    ( increments the string stack item count)
    1 ($depth) +! ;

: ($sp@) ( -- addr ) ($sp) @ ;

: ($rUp) ( n -- n|n+1)
    ( rounds n up to the next even value)
    1+ -2 AND ;

: cell+ ( n -- n+2) COMPILE 2+ ; IMMEDIATE

: (sizeOf$) ( $addr - $size)
    ( given an address of a transient string, compute the stack )
    ( size in bytes required to hold it, rounded up to the      )
    ( nearest even cell size, and including the length cell.    )
    @ ($rUp) cell+ ;

: (set$SP) ( $size -- ) 
    ( given the stack size of a transient string set the string   )
    ( stack pointer to the new address required to accomodate it. )
    MINUS DUP ($sp@) + ($sEnd) < IF 9900 (throw) THEN 
    ($sp) +! ;
    
: (addrOf$) ( index -- addr )
    ( given an index into the string stack, return the start )
    ( address of the string. addr points to the length cell. )
    ( topmost string is index 0 )
    ( next string is index 1 and so on )
    ($sp@) SWAP DUP IF 0 DO 
        DUP (sizeOf$) + LOOP ELSE DROP THEN ;
    
: (lenOf$) ( $addr -- len )
    ( given the address of a transient string on the string )
    ( stack , return the length of the string. )
    STATE @ IF COMPILE @ ELSE @ THEN ; IMMEDIATE

: RESET$ ( -- ) ( "reset i.e. empty the string stack")
    0 ($depth) !  ($sEnd) ($sSize) + ($sp) ! ;
    
: DEPTH$ ( -- $sDepth) ( "depth of string stack" )
    ( returns the current depth of the string stack. )
    ($depth) @ ;

: $CONST ( max_len tib:"name" -- ) ( runtime: -- $Caddr)
    ( "string constant" )
    ( creates a string constant )
    ( when name is referenced the address of the max_len field )
    ( is pushed to the stack. )
    ( e.g. 100 $CONST FRED \ create a string called fred )
   <BUILDS  ($rUp) DUP , 0 ,  ALLOT DOES> NOP ;
    
: CLEN$ ( $Caddr -- len ) ( "string constant length" )
    ( given the address of a string constant, returns its length )
    cell+ @ ;
    
: MAXLEN$ ( $Caddr -- max_len ) ( "string constant maximum length" )
    ( given the address of a string constant, returns its maximum length)
    (lenOf$) ;

: .$CONST ( $Caddr -- ) ( "display string constant")
    ( displays the string constant. e.g. fred .$const)
    cell+ DUP (lenOf$) SWAP cell+ SWAP TYPE ;
    
: :=" ( $Caddr tib:"string" -- ) ( "assign string constant")
    ( assigns the string "string" to the string constant)
    ( e.g. fred :=" hello mother!" )
    DUP @  34 WORD HERE COUNT  SWAP >R  2DUP < IF 9901 (throw) THEN
    NIP 2DUP SWAP cell+ !  >R [ 2 CELLS ] LITERAL + R> R> -ROT CMOVE ;

: ($") ( addr len -- ) ( ss: -- str )
    ( run-time action for $" )
    DUP ($rUp) cell+ (set$SP)
    DUP ($sp@) !  ($sp@) cell+ SWAP CMOVE  ($depth+) ;

: (COMPILE$) ( addr len -- )
    ( compiles a string in-line inside a colon definition, such that, )
    ( when the definition is executed, the in-line string is pushed   )
    ( onto the string stack )
    ( MRW: Written explicitly for fbForth port )
    DUP >R ( save length) 
    PAD SWAP CMOVE ( move the string to pad)
    ( now compile the address of the string as a literal... )
    HERE 6 CELLS  COMPILE LIT  + ,
    ( now compile length of string as a literal... )
    COMPILE LIT R ,
    ( compile a branch over the string... )
    COMPILE BRANCH  HERE  R ($rUp) +  HERE - 2+ ,
    ( move string from PAD to HERE... )
    PAD 12 - R  HERE SWAP CMOVE
    ( allot space over the string... )
    R> ($rUp) ALLOT 
    COMPILE ($") ;
        
: $" ( tib:"string" -- ) ( ss: -- str) ( "string to string stack" )
    ( pushes a string directly to the string stack )
    ( e.g. $" hello world" .$ )
    ( MRW: Changed for fbForth )
    34 WORD HERE COUNT
    STATE @ IF (COMPILE$) ELSE ($") THEN ; IMMEDIATE 

: >$ ( $Caddr -- ) ( ss: -- str) ( "string constant to string stack" )
    ( moves a string constant to the string stack )
    ( e.g. fred >$ )
    cell+ DUP (lenOf$) SWAP cell+ SWAP ($") ;

: PICK$ ( n -- ) ( ss: -- strN) ( "pick string" )
    ( given an index into the string stack, copy the indexed )
    ( string to the top of the string stack. )
    ( 0 $pick is equivalent to $DUP )
    ( 1 $pick is equivalent to $OVER etc. )
    DEPTH$ 0= IF 9902 (throw) THEN 
    (addrOf$) DUP (lenOf$) SWAP cell+ SWAP ($") ;

: DUP$ ( -- ) ( ss: s1 -- s1 s1) ( "duplicate string" )
    ( duplicates a string on the string stack )
    DEPTH$ 0= IF 9902 (throw) THEN  0 PICK$ ;

: DROP$ ( -- ) ( ss: str -- ) ( "drop string" )
    ( drops the top string from the string stack )
    DEPTH$ 0= IF 9902 (throw) THEN
    ($sp@) (sizeOf$) MINUS (set$SP)  -1 ($depth) +! ;
    
: SWAP$ ( -- ) ( ss: s1 s2 -- s2 s1) ( "swap strings")
    ( swaps the top two string items on the string stack)
    DEPTH$ 2 < IF 9903 (throw) THEN 
    ($sp@) DUP (sizeOf$) HERE SWAP CMOVE
    1 (addrOf$) DUP (sizeOf$) ($sp@) SWAP CMOVE
    HERE DUP (sizeOf$)  ($sp@) DUP (sizeOf$) + SWAP CMOVE ;

: NIP$ ( -- ) ( ss: s1 s2 -- s2) ( "nip strings")
    ( remove the string under the top string)
    DEPTH$ 2 < IF 9903 (throw) THEN  SWAP$ DROP$ ;
    
: OVER$ ( -- ) ( ss: s1 s2 -- s1 s2 s1) ( "over string")
    ( move a copy of s1 to top of string stack )
    DEPTH$ 2 < IF 9903 (throw) THEN  1 PICK$ ;
    
: (rot$) ( -- ) ( ss: s6 s5 s4 s3 s2 s1 -- s3 s2 s1)
    ( internal factor of rot$ and -rot$. See below. )
    ( source:) ($sp@)  ( destination:) 3 (addrOf$)
    ( #bytes to move: ) 
    ($sp@) (sizeOf$)   1 (addrOf$) (sizeOf$)   2 (addrOf$) (sizeOf$) + + 
    ( move s1 to s3 into the space occupied by s4 to s6:) CMOVE
    ( adjust string stack pointer:) 3 (addrOf$) ($sp) !  -3 ($depth) +! ;

: ROT$ ( -- ) ( ss: s3 s2 s1 -- s2 s1 s3) ( "string rotate left")
    ( rotates the top three strings to the left.)
    DEPTH$ 3 < IF 9906 (throw) THEN 
    1 PICK$  1 PICK$  4 PICK$ (rot$) ;

: -ROT$ ( -- ) ( ss: s3 s2 s1 -- s1 s3 s2) ( "string rotate right" )
    ( rotates the top three strings to the right. )
    DEPTH$ 3 < IF 9906 (throw) THEN
    0 PICK$  3 PICK$  3 PICK$ (rot$) ;
    
: LEN$ ( -- len ) ( ss: -- ) ( "length of string")
    ( returns the length of the topmost string.)
    DEPTH$ 1 < IF 9902 (throw) THEN  ($sp@) @ ;    

: >$CONST ( $Caddr -- ) ( ss: str -- ) ( "to string constant")
    ( move top of string stack to the string constant)
    ( e.g. $" blue" fred >$const  fred .$const )
    ( displays "blue" )
    >R  DEPTH$ 1 < IF 9902 (throw) THEN
    LEN$ R @ > IF 9904 (throw) THEN
    ($sp@) DUP (sizeOf$) R> cell+ SWAP CMOVE DROP$ ;

: +$ ( -- ) ( ss: s1 s2 -- s2+s1) ( "concatenate strings")
    ( replaces the top most two strings on the string stack)
    ( with their concatenated equivalent.)
    ( eg: $" red" $" blue" $& .$ )
    ( displays "redblue" )
    DEPTH$ 2 < IF 9903 (throw) THEN 
    1 (addrOf$) cell+  HERE   1 (addrOf$) (lenOf$)  CMOVE
    ($sp@) cell+   1 (addrOf$) (lenOf$) HERE +  LEN$ CMOVE
    HERE LEN$ 1 (addrOf$) (lenOf$) +  DROP$ DROP$  ($") ;    

: MID$ ( start len -- ) ( ss: str1 -- str1 str2) ( "mid string")
    ( the characters from start to start+len are pushed to the string stack )
    ( as a new string. the original string is retained. )
    DEPTH$ 1 < IF 9902 (throw) THEN 
    DUP LEN$ >  OVER 1 < OR  IF 9905 (throw) THEN
    OVER DUP LEN$ >  SWAP 0< OR IF 9908 (throw) THEN 
    SWAP ($sp@) cell+ +  SWAP  ($") ;

: LEFT$ ( len -- ) ( ss: str1 -- str1 str2) ( "left string" )
    ( the leftmost len characters are pushed to  the string )
    ( stack as a new string. The original string is retained. )
    DEPTH$ 1 < IF 9902 (throw) THEN 
    DUP LEN$ > OVER 1 < OR IF 9905 (throw) THEN 
    0 ($sp@) cell+ +  SWAP  ($") ;
   
: RIGHT$ ( len -- ) ( ss: str1 -- str1 str2) ( "right string")
    ( the rightmost len characters, pushed to the string stack )
    ( as a new string. the original string is retained. )
    DEPTH$ 1 < IF 9902 (throw) THEN 
    DUP LEN$ > OVER 1 < OR IF 9905 (throw) THEN 
    ($sp@) (lenOf$) OVER - ($sp@) cell+ +  SWAP  ($") ;

: FINDC$ ( char -- pos|-1 ) ( ss: -- ) ( "find char")
    ( returns the first occurance of the character char in )
    ( the top string. The string is retained. )
    ( returns -1 if the char is not found )
    ( MRW: Changed for fbForth as LEAVE works differently in FIG )
    DEPTH$ 1 < IF 9902 (throw) THEN
    -1 ($temp0) ! ( assume not found )
    ($sp@) cell+  ($sp@) (lenOf$) 0 DO
        DUP C@ 2 PICK = IF I ($temp0) ! LEAVE THEN 1+ LOOP
    DROP DROP ($temp0) @ ;

: FIND$ ( offset -- pos|-1 ) ( ss: s1 s2 -- s1) ( "find string" )
    ( searches string str1, beginning at offset, for the substring str2. )
    ( if the string is found, returns the position of the string relative )
    ( to the offset, otherwise returns -1. )
    DEPTH$ 2 < IF 9903 (throw) THEN 
    LEN$ ($temp1) !    1 (addrOf$) (lenOf$) ($temp0) !
    DUP ($temp0) @ > IF DROP -1 EXIT THEN 
    1 (addrOf$) cell+ + ($temp2) !    ($sp@) cell+ ($temp3) !
    ($temp1) @ ($temp0) @ > IF DROP -1 EXIT THEN 
    0  ($temp0) @ 0 DO
        ($temp3) @ OVER + C@ 
        ($temp2) @ I + C@ = IF
            1+ DUP ($temp1) @ = IF 
                DROP I ($temp1) @ - 1+   -2 LEAVE THEN 
        ELSE DROP 0 THEN
    LOOP 
    DUP -2 = IF DROP ELSE DROP -1 THEN DROP$ ;

: .$ ( -- ) ( ss: str -- ) ( "display string" )
    ( pop and display string from string stack )
    DEPTH$ 0= IF 9902 (throw) THEN 
    ($sp@) cell+ ($sp@) (lenOf$) TYPE  DROP$ ;
    
: REV$ ( -- ) ( ss: s1 -- s2 ) ( "reverse string" )
    ( reverse top string on string stack. )
    DEPTH$ 0= IF 9902 (throw) THEN 
    ($sp@) DUP cell+ >R  (lenOf$)  R> SWAP HERE SWAP CMOVE 
    ($sp@) (lenOf$) HERE 1- +
    ($sp@) cell+  DUP ($sp@) (lenOf$) +   SWAP DO
        DUP C@ I C!  1- LOOP  DROP ;

: LTRIM$ ( -- ) ( ss: s1 -- s2 ) ( "left trim string" )
    ( removes leading spaces from s1, resulting in s2. )
    DEPTH$ 0= IF 9902 (throw) THEN  
    ($sp@) DUP (lenOf$) >R  HERE OVER (sizeOf$)  CMOVE
    0  R> HERE cell+ DUP >R +  R> DO
        I C@ BL = IF 1+ ELSE LEAVE THEN LOOP 
    DUP 0 > IF 
        >R  ($sp@) (lenOf$)  DROP$
        HERE cell+ R +  SWAP R> -  ($")
    ELSE DROP THEN ;

: RTRIM$ ( -- ) ( ss: s1 -- s2 ) ( "right trim string" )
    ( removes trailing spaces from s1, resulting in s2. )
    DEPTH$ 0= IF 9902 (throw) THEN  REV$ LTRIM$ REV$ ;

: TRIM$ ( -- ) ( ss: s1 -- s2 ) ( "trim string" )
    ( remove both leading and trailing spaces from s1, )
    ( resulting in s2. )
    RTRIM$ LTRIM$ ;

: REPLACE$ ( -- pos ) ( "replace string" )
    ( found: ss: s1 s2 s3 -- s4  not found: s1 s2 -- s1 s2)
    DEPTH$ 3 < IF 9906 (throw) THEN
    LEN$ >R
    0 FIND$ DUP ($temp0) ! -1 > IF
        ($sp@) cell+  HERE  ($temp0) @ CMOVE  
        1 (addrOf$) cell+   HERE ($temp0) @ +  
        1 (addrOf$) (lenOf$) CMOVE
        ($sp@) cell+ ($temp0) @ + R +    
        HERE ($temp0) @ + 1 (addrOf$) (lenOf$) +
        LEN$ R> - ($temp0) @ -  DUP >R  CMOVE
        R> ($temp0) @ + 1 (addrOf$) (lenOf$) +
        DROP$ DROP$ HERE SWAP ($")
    ELSE R> DROP ($temp0) @ THEN ;

: UCASE$ ( -- ) ( ss: str -- STR) ( "to upper case" )
    ( on the topmost string, converts all lower case characters )
    ( to upper case. )
    DEPTH$ 1 < IF 9902 (throw) THEN
    ($sp@) DUP (lenOf$) + cell+  ($sp@) cell+  DO
       I C@ DUP 97 123 WITHIN IF 
            32 -  I C! ELSE DROP THEN LOOP ;

: LCASE$ ( -- ) ( ss: STR -- str) ( "to lower case" )
    ( on the topmost string, converts all upper case characters )
    ( to lower case. )
    DEPTH$ 1 < IF 9902 (throw) THEN 
    ($sp@) DUP (lenOf$) + cell+  ($sp@) cell+  DO
       I C@ DUP  65 91 WITHIN IF 
            32 +  I C! ELSE DROP THEN LOOP ;

: ==$? ( -- flag ) ( ss: -- ) ( "are strings equal?" )
    ( performs a case-sensitive comparison of the topmost )
    ( two strings on the string stack, returning true if their )
    ( length and contents are identical, otherwise returning )
    ( false. )
    ( MRW: Changed for fbForth as LEAVE works differently in FIG )
    DEPTH$ 2 < IF 9903 (throw) THEN 
    LEN$  1 (addrOf$) (lenOf$) = IF
        0 ($temp0) ! ( assume not same )
        1 (addrOf$) cell+ ( point to first char of string 1)
        ($sp@) cell+  DUP LEN$ + SWAP  DO
            DUP C@  I C@  <> IF -99 ($temp0) ! LEAVE THEN 1+
        LOOP
        DROP ($temp0) @ -99 <> 
    ELSE 0 THEN ;
   
: VAL$ ( -- ud ) ( ss: str -- ) ( "value of string" )
    ( interprets the topmost string as an integer number, returning its )
    ( value on the data stack as a double. )
    ( MRW: Re-written for fbForth as FIG NUMBER expects a packed string. )
    ($sp@) DUP (lenOf$) SWAP cell+ SWAP DUP >R PAD 1+ SWAP CMOVE
    R> PAD C! 
    0 0 PAD (NUMBER) DROP DROP$ ;

: $.S ( -- ) ( ss: -- ) ( "display string stack" )
    CR  DEPTH$ 0 > IF
        ($sp@)  DEPTH$
        ."  Index|Length|String" CR
        ." ------+------+------" CR 
        0 BEGIN
            DEPTH$ 0 > WHILE
                DUP 6 .R ." |" LEN$ 6 .R  ." |" .$  1+ CR
        REPEAT  DROP
        ($depth) !  ($sp) !  CR
    ELSE
        ." String stack is empty." CR
    THEN
    ." Allocated stack space:"
    ($sEnd) ($sSize) + ($sp@) - 4 .R ."  bytes" CR
    ."     Total stack space:"
    ($sSize) 4 .R ."  bytes" CR
    ." Stack space remaining:" 
    ($sp@) ($sEnd) - 4 .R ."  bytes" CR ;

BASE ! 

$" RED" $" GREEN" $" BLUE" $.S
